/*****************************************************************************/
/*      (c) Copyright 2006 Rapid Deployment Software - See License.txt       */
/*****************************************************************************/
/*                                                                           */
/*                        C INTERFACE / MACHINE FUNCTION                     */
/*                                                                           */
/*****************************************************************************/

/* BUG FIX: (Borland and LCC-Win32) dir() was not showing sub-directories/files
            of a given directory if attributes element was an or'd value.
            Fixed by EUMAN aka H.W Overman > Jan 1, 2002
*/

/* It's ok to assume that a machine_func/machine_proc call
   is coming from a standard .e file, as far as arguments being sequences
   versus atoms, but don't assume integers will be in 31-bit
   machine integer format just because of the integer type
   check conversion. We must allow the user to call machine_func/
   machine_proc directly, even if he passes integers in f.p. format */

#include <stdio.h>
#include <stdlib.h>

#ifdef ELINUX
# ifdef EBSD
#  define NAME_MAX 255
# else
#  include <sys/mman.h>
# endif
# include <dirent.h>
# include <sys/stat.h>
# include <sys/file.h>
# include <dlfcn.h>
# include <sys/times.h>
# include <unistd.h>
# include <termios.h>
# include <sys/ioctl.h>
# ifdef EBSD
#  include <sys/types.h>
   /// CHECKME - Does BSD need sys/types.h here?
   /// J.A. -> This used to be included on Linux and BSD, but I moved it to BSD
   /// only when I found out that Linux didn't need it.
# endif
#endif

#ifdef EWINDOWS
# include <direct.h>
# ifdef EBORLAND
#  include <io.h>
#  include <dos.h>
#  include <dir.h>
# endif
# ifdef ELCC
#  include <io.h>
# endif
# ifdef EWATCOM
#  include <graph.h>
#  include <i86.h>
# endif
#endif

#include <time.h>
#include <string.h>

#ifdef EXTRA_CHECK
# include <malloc.h>
#endif

#ifdef EWINDOWS
# include <windows.h>
#endif

#include "global.h"
#include "execute.h"
#include "symtab.h"
#include "reswords.h"

#include <signal.h>

/*****************/
/* Local defines */
/*****************/

#define MASTER_FREQUENCY 1193181.667
#if __GNUC__ == 4
# define CALLBACK_SIZE 92
#else
# define CALLBACK_SIZE 80
#endif

/**********************/
/* Exported variables */
/**********************/

#ifdef EWINDOWS
HINSTANCE winInstance;
#endif
#ifdef EXTRA_STATS
int mouse_ints = 0;  /* number of unused mouse interrupts */
#endif

char *crash_msg = NULL;  /* user's crash message or NULL */

double base_time = 0.0;          /* current base for time() */
double clock_adjust = 0.0;       /* adjustment to clock() value */
double clock_frequency = 0.0;    /* current clock interrupt rate. 0.0
                                    means no interrupt handler installed */

int allow_break = TRUE;       /* allow control-c/control-break to kill prog */
int col_max;                  /* current number of text columns on screen */
int crash_routines = 0;    // number of routines
int c_routine_next = 0;       /* index of next available element */
int c_routine_size = 0;       /* number of c_routine structs allocated */
int line_max;                 /* current number of text lines on screen */

int *crash_list = NULL;    // list of routines to call when there's a crash

struct arg_info *c_routine = NULL; /* array of c_routine structs */
struct videoconfig config;

unsigned current_fg_color = 7;
unsigned current_bg_color = 0;

unsigned char TempBuff[TEMP_SIZE]; /* buffer for error messages */

/**********************/
/* Imported variables */
/**********************/

#ifdef ELINUX
extern int pagesize;
extern struct char_cell screen_image[MAX_LINES][MAX_COLS];
#endif
#ifdef EWINDOWS
extern HANDLE console_output;
extern unsigned default_heap;
#endif

extern char *TempErrName;

extern double clock_period;

extern FILE *last_w_file_ptr;

extern int clk_tck;
extern int clocks_per_sec;
extern int current_screen;
extern int e_routine_next;
extern int have_console;
extern int rand_was_set;
extern int screen_line;
extern int screen_col;

extern long last_w_file_no;
extern long seed1;
extern long seed2;

extern struct file_info user_file[];

extern symtab_ptr TopLevelSub;

extern symtab_ptr *e_routine;

/*******************/
/* Local variables */
/*******************/

char *version_name =
#ifdef EWINDOWS
"WIN32";
#endif
#ifdef ELINUX
"Linux";
#endif

#ifdef EWINDOWS
HINSTANCE *open_dll_list = NULL;

int open_dll_count = 0;
int open_dll_size = 20;
#endif

#ifdef ELINUX
static char *bl20 = "                    ";

struct termios savetty; // initial tty state for STDIN
struct termios newtty;  // current tty state for STDIN
#endif

static int crash_size = 0;        // space allocated for crash_list

extern struct IL fe;
typedef struct IL il;

/**********************/
/* Declared Functions */
/**********************/

#ifdef ELINUX
struct rccoord _gettextposition();
#endif

char *EMalloc();

FILE *which_file();

object SetBColor();
object SetTColor();

s1_ptr NewS1();

void AfterExecute(void);
void do_exec(int *);
void NewConfig();
void Machine_Handler();


/* cdecl callback - one size fits all */
LRESULT __cdecl cdecl_call_back();

/* stdcall callbacks for each number of args */
LRESULT CALLBACK call_back0();
LRESULT CALLBACK call_back1(unsigned);
LRESULT CALLBACK call_back2(unsigned, unsigned);
LRESULT CALLBACK call_back3(unsigned, unsigned, unsigned);
LRESULT CALLBACK call_back4(unsigned, unsigned, unsigned, unsigned);
LRESULT CALLBACK call_back5(unsigned, unsigned, unsigned, unsigned, unsigned);
LRESULT CALLBACK call_back6(unsigned, unsigned, unsigned, unsigned, unsigned,
                            unsigned);
LRESULT CALLBACK call_back7(unsigned, unsigned, unsigned, unsigned, unsigned,
                            unsigned, unsigned);
LRESULT CALLBACK call_back8(unsigned, unsigned, unsigned, unsigned, unsigned,
                            unsigned, unsigned, unsigned);
LRESULT CALLBACK call_back9(unsigned, unsigned, unsigned, unsigned, unsigned,
                            unsigned, unsigned, unsigned, unsigned);

unsigned long get_pos_int(char *where, object x)
/* return a positive integer value if possible */
{
    if (IS_ATOM_INT(x))
        return INT_VAL(x);
    else if (IS_ATOM(x))
        return (unsigned long)(DBL_PTR(x)->dbl);
    else {
        sprintf(TempBuff,
        "%s: an integer was expected, not a sequence", where);
        RTFatal(TempBuff);
    }
}

FILE *long_fopen(char *name, char *mode)
/* fopen a file. Has support for Windows 95 long filenames */
{
    return fopen(name, mode);
}

int long_open(char *name, int mode)
/* open a file. Has support for Windows 95 long filenames */
{
    return open(name, mode);
}

char *name_ext(char *s)
/* returns a pointer to the 8.3 file name & extension part of a path */
/* Note - forward slash is also legal on Windows - fix? */
{
    int i;

    i = strlen(s);
    while (i >= 0 && s[i] != '\\' && s[i] != '/') // check for ':' too? ok as used so far
        i--;
    if (i >= 0)
        return s + i + 1;
    else
        return s;
}

static long get_int(object x)
/* return an integer value if possible */
/* Note: uses (long) conversion of doubles
   - NOT CORRECT for 32-bit addresses */
{
    if (IS_ATOM_INT(x))
        return x;
    else if (IS_ATOM(x))
        return (long)(DBL_PTR(x)->dbl);
    else {
        RTFatal("an integer was expected, not a sequence");
    }
}

#ifdef ELINUX

void echo_wait()
// sets tty to wait for input and echo keystrokes
{
    newtty.c_lflag |= ICANON;
    newtty.c_lflag |= ECHO;   // turns on echo
    newtty.c_cc[VMIN] = 1;    // wait for input
    tcsetattr(STDIN_FILENO, TCSANOW, &newtty);
}

void noecho(int wait)
// sets tty to not echo keystrokes, and either wait for input or not
{
    newtty.c_lflag &= ~ICANON;
    newtty.c_lflag &= ~ECHO;   // turns off echo
    newtty.c_cc[VMIN] = wait;  // wait for input, if wait = 1
    tcsetattr(STDIN_FILENO, TCSANOW, &newtty);
}
#endif

void InitGraphics()
/* initialize for graphics */
{
#ifdef ELINUX
    // save initial tty state
    tcgetattr(STDIN_FILENO, &savetty);

    // set up tty for no echo
    newtty = savetty;
    newtty.c_cc[VTIME] = 0;
    //noecho(0); // necessary?
#endif
    NewConfig();
}

void EndGraphics()
{
#ifdef EWINDOWS
    SetConsoleMode(console_output,
                    ENABLE_PROCESSED_OUTPUT | ENABLE_WRAP_AT_EOL_OUTPUT); // back to normal
#elif ELINUX
    tcsetattr(STDIN_FILENO, TCSANOW, &savetty);
#endif
}

void not_supported(char *feature)
/* Report that a feature isn't supported on this platform */
{
    char buff[100];

    sprintf(buff, "%s is not supported in Euphoria for %s",
                  feature, version_name);
    RTFatal(buff);
}

void NewConfig()
/* note new video configuration - this doesn't work
   after a system call that changes modes - could be out of sync */
{
#ifdef EWINDOWS
    CONSOLE_SCREEN_BUFFER_INFO info;

    if (have_console) {
        GetConsoleScreenBufferInfo(console_output, &info);
        line_max = info.dwSize.Y;
        col_max = info.dwSize.X;
    }
    else {
        line_max = 25;
        col_max = 80;
    }
    config.numtextrows = line_max;
    config.numtextcols = col_max;

    config.mode = 3;
    config.monitor = _COLOR;
    config.numcolors = 32;
    config.numxpixels = 0;
    config.numypixels = 0;
    config.numvideopages = 1;
#endif

#ifdef ELINUX
    char *env_lines;
    char *env_cols;
    int x;
    struct winsize ws;

    config.mode = 3;
    config.numxpixels = 0;
    config.numypixels = 0;
    config.numvideopages = 1;
    line_max = 0;
    col_max = 0;

    env_lines = getenv("LINES");
    if (env_lines != NULL) {
        x = atoi(env_lines);
        if (x > 0 && x < 9999) {
            // value looks reasonable
            line_max = x;
        }
    }
    env_cols = getenv("COLUMNS");
    if (env_cols != NULL) {
        x = atoi(env_cols);
        if (x > 0 && x < 99999) {
            // value looks reasonable
            col_max = x;
        }
    }

    if ((line_max == 0 || col_max == 0) &&
        !ioctl(STDIN_FILENO, TIOCGWINSZ, &ws)) {
        line_max = ws.ws_row;
        col_max = ws.ws_col;
    }

    if (line_max < 5 || line_max > 9999 ||
        col_max < 10 || col_max > 99999) {
        // something is wrong - use default pessimistic values
        line_max = 24;  // default value
        col_max = 80;   // default value
    }

    if (line_max > MAX_LINES)
        line_max = MAX_LINES;
    if (col_max > MAX_COLS)
        col_max = MAX_COLS;

    config.monitor = _COLOR;
    config.numcolors = 16;
    config.numtextrows = line_max;
    config.numtextcols = col_max;
#endif

    screen_col = 1;
}

static object Graphics_Mode(object x)
/* x is the graphics mode */
{
#ifdef EWINDOWS
    show_console();
#endif
    return ATOM_0;
}

static object Video_config()
/* video_config built-in */
{
    object_ptr obj_ptr;
    s1_ptr result;
#ifdef EWINDOWS
    show_console();
#endif
    result = NewS1((long)8);
    obj_ptr = result->base;

    obj_ptr[1] = (config.monitor != _MONO) &&
                 (config.monitor != _ANALOGMONO);
    obj_ptr[2] = config.mode;
    obj_ptr[3] = config.numtextrows;
    obj_ptr[4] = config.numtextcols;
    obj_ptr[5] = config.numxpixels;
    obj_ptr[6] = config.numypixels;
    obj_ptr[7] = config.numcolors;
    obj_ptr[8] = config.numvideopages;
    return MAKE_SEQ(result);
}

static object Cursor(object x)
/* set style of cursor */
{
    short style;

    style = get_int(x);

#ifdef EWINDOWS
    CONSOLE_CURSOR_INFO c;

    c.dwSize = (style == 0x0607) ? 12 :
               (style == 0x0507) ? 25 :
               (style == 0x0407) ? 50 :
                                  100;
    c.bVisible = (style != 0x02000);
    SetConsoleCursorInfo(console_output, &c);
#endif
#ifdef ELINUX
    // leaveok(stdscr, style != 0x02000); doesn't work very well
#endif
    return ATOM_1;
}

static object TextRows(object x)
/* text_rows built-in */
{
#ifdef EWINDOWS
    COORD newsize;
    int rows, new_rows;

    new_rows = get_int(x);
    show_console();
    newsize.X = 80; // what about 40-char modes?
    newsize.Y = new_rows;
    SetConsoleScreenBufferSize(console_output, newsize);
#endif
    NewConfig();
    return MAKE_INT(line_max);
}

object Wrap(object x)
/* set line wrap mode */
{
#ifdef EWINDOWS
    show_console();
#endif
    return ATOM_1;
}

#ifdef ELINUX
void blank_lines(int line, int n)
// Write n blank lines at the specified line (origin 0).
// The cursor is moved.
{
    int b;
    int j;

    for (j = 1; j <= n; j++) {
        b = config.numtextcols;
        SetPosition(++line, 1);
        while (b >= 20) {
            fputs(bl20, stdout); // 20 blanks
            update_screen_string(bl20);
            screen_col += 20;
            b -= 20;
        }
        while (b >= 1) {
            fputs(" ", stdout); // 1 blank
            update_screen_string(" ");
            screen_col += 1;
            b -= 1;
        }
    }
    if (n)
      fflush(stdout);
}
#endif

void do_scroll(int top, int bottom, int amount)
// scroll the screen from top line to bottom line by amount
// amount is positive => text moves up
{
#ifdef EWINDOWS
    SMALL_RECT src, clip;
    COORD dest;
    CHAR_INFO fill_char;
    CONSOLE_SCREEN_BUFFER_INFO info;

    show_console();
    src.Left = 0;
    src.Right = 79; // assume for now !!!
    src.Top = top - 1;
    src.Bottom = bottom - 1;
    clip = src;
    dest.X = 0;
    dest.Y = src.Top - amount; // for now
    GetConsoleScreenBufferInfo(console_output, &info);
    fill_char.Char.AsciiChar = ' ';
    fill_char.Attributes = info.wAttributes;
    if (abs(amount) > abs(bottom - top)) {
        EClearLines(top, bottom, info.dwSize.X, fill_char.Attributes);
    }
    else {
        ScrollConsoleScreenBuffer(console_output,
                              &src,
                              &clip,
                              dest,
                              &fill_char);
    }
#elif ELINUX
    short r1, c1;
    int b, bg, fg, i, j, prev_b, prev_t, t;

    // save the current position
    r1 = screen_line;
    c1 = screen_col;
    fg = current_fg_color;
    bg = current_bg_color;
    prev_t = -1;
    prev_b = -1;
    if (abs(amount) > abs(bottom - top)) {
        // clear the window
        blank_lines(top-1, bottom-top+1);
    }
    else if (amount > 0) {
        // copy some lines up
        for (i = top; i <= bottom - amount; i++) {
            SetPosition(i, 1);
            for (j = 0; j < col_max; j++) {
                screen_image[i-1][j] = screen_image[i+amount-1][j];
                t = screen_image[i+amount-1][j].fg_color;
                b = screen_image[i+amount-1][j].bg_color;
                if (t != prev_t) {
                    SetTColor(t);
                    prev_t = t;
                }
                if (b != prev_b) {
                    SetBColor(b);
                    prev_b = b;
                }
                fputc(screen_image[i+amount-1][j].ascii, stdout);
            }
            //screen_line++;
        }
        // put blank lines at bottom
        SetBColor(bg);
        blank_lines(bottom-amount, amount);
        fflush(stdout);
    }
    else if (amount < 0) {
        // copy some lines down
        for (i = bottom; i >= top-amount; i--) {
            SetPosition(i, 1);
            for (j = 0; j < col_max; j++) {
                screen_image[i-1][j] = screen_image[i+amount-1][j];
                t = screen_image[i+amount-1][j].fg_color;
                b = screen_image[i+amount-1][j].bg_color;
                if (t != prev_t) {
                    SetTColor(t);
                    prev_t = t;
                }
                if (b != prev_b) {
                    SetBColor(b);
                    prev_b = b;
                }
                fputc(screen_image[i+amount-1][j].ascii, stdout);
            }
            //screen_line--;
        }
        // put blanks lines at top
        SetBColor(bg);
        blank_lines(top-1, -amount);
        fflush(stdout);
    }
    // restore the current position
    SetPosition(r1, c1);
    SetTColor(fg); // bg will be restored already
    current_fg_color = fg;
    current_bg_color = bg;
#endif
}

static object Scroll(object x)
{
    int amount, top, bottom;
    int i;

    x = (object)SEQ_PTR(x);
    amount = get_int(*(((s1_ptr)x)->base+1));
    top =    get_int(*(((s1_ptr)x)->base+2));
    // top is higher on the screen, i.e. with a lower line number
    bottom = get_int(*(((s1_ptr)x)->base+3));
    do_scroll(top, bottom, amount);
    return ATOM_1;
}

object SetTColor(object x)
/* SET TEXT COLOR */
{
    short c;

    c = get_int(x);

#ifdef EWINDOWS
    CONSOLE_SCREEN_BUFFER_INFO con_info;
    WORD attribute;

    show_console();

    GetConsoleScreenBufferInfo(console_output, &con_info);
    attribute = (c & 0x0f) | (con_info.wAttributes & 0xf0);
    SetConsoleTextAttribute(console_output, attribute);
#elif ELINUX
    current_fg_color = c & 15;
    if (current_fg_color > 7)
        fputs("\033[1m", stdout); // BOLD ON (BRIGHT)
    else
        fputs("\033[22m", stdout); // BOLD OFF
    fputs("\033[3", stdout);
    fputc('0' + (current_fg_color & 7), stdout);
    fputc('m', stdout);
#endif

    return ATOM_1;
}

object SetBColor(object x)
/* SET BACKGROUND COLOR */
{
    int c;
    c = get_int(x);

#ifdef EWINDOWS
    WORD attribute;
    CONSOLE_SCREEN_BUFFER_INFO con_info;

    show_console();

    GetConsoleScreenBufferInfo(console_output, &con_info);
    attribute = ((c & 0x0f) << 4) | (con_info.wAttributes & 0x0f);
    SetConsoleTextAttribute(console_output, attribute);
#endif
#ifdef ELINUX
    current_bg_color = c & 7;
    // ANSI code
    fputs("\033[4", stdout);
    fputc('0' + current_bg_color, stdout);
    fputc('m', stdout);
#endif

    return ATOM_1;
}

object user_allocate(object x)
/* x is number of bytes to allocate */
{
    int nbytes;
    char *addr;
#ifdef ELINUX
    unsigned first, last, gp1;
#endif

    nbytes = get_int(x);
    addr = malloc(nbytes);
#ifdef ELINUX
#ifndef EBSD
    // make it executable
    gp1 = pagesize-1;
    first = (unsigned)addr & (~gp1); // start of page
    last = (unsigned)addr+nbytes-1; // last address
    last = last | gp1; // end of page
    mprotect((void *)first, last - first + 1,
             PROT_READ+PROT_WRITE+PROT_EXEC);
#endif
#endif

    // we don't allow -ve addresses, so can't use -ve Euphoria ints
    if ((unsigned long)addr <= (unsigned)MAXINT_VAL)
        return (unsigned long)addr;
    else
        return NewDouble((double)(unsigned long)addr);
}

static object Where(object x)
/* x is the file number. return current byte position */
{
    int file_no, result;
    FILE *f;

    file_no = CheckFileNumber(x);
    if (user_file[file_no].mode == EF_CLOSED)
        RTFatal("file must be open for where()");
    f = user_file[file_no].fptr;
#ifdef EWATCOM
    if (user_file[file_no].mode & EF_APPEND)
        fflush(f);  // This fixes a bug in Watcom 10.6 that is fixed in 11.0
#endif
    result = ftell(f);
    if (result == -1)
        RTFatal("where() failed on this file");
    if (result > MAXINT_VAL || result < MININT_VAL)
        result = NewDouble((double)result);  // maximum 2 billion
    return result;
}

static object Seek(object x)
/* x is {file number, new position} */
{
    int file_no, result;
    long pos;
    FILE *f;
    object x1, x2;

    x = (object)SEQ_PTR(x);
    x1 = *(((s1_ptr)x)->base+1);
    x2 = *(((s1_ptr)x)->base+2);
    file_no = CheckFileNumber(x1);
    if (user_file[file_no].mode == EF_CLOSED)
        RTFatal("file must be open for seek()");
    f = user_file[file_no].fptr;
    pos = get_pos_int("seek", x2);
    if (pos == -1)
        result = fseek(f, 0L, SEEK_END);
    else
        result = fseek(f, pos, SEEK_SET);
    return MAKE_INT(result);
}

// 3 implementations of dir()

#if defined(ELCC) || defined(EBORLAND)
    // 1 of 3: findfirst method

static object Dir(object x)
/* x is the name of a directory or file */
{
    char path[MAX_FILE_NAME+1+4];
    s1_ptr result, row;
#ifdef EBORLAND
    struct ffblk direntp;
#else
    struct _finddata_t direntp;
#endif
    object_ptr obj_ptr, temp;
    int dirp, last, bits;
    unsigned date, time, attrib;

    /* x will be sequence if called via dir() */

    if (SEQ_PTR(x)->length > MAX_FILE_NAME)
        RTFatal("name for dir() is too long");

    MakeCString(path, x);

    bits = _A_SUBDIR | _A_HIDDEN | _A_SYSTEM;

           //FA_RDONLY | FA_HIDDEN |
           //FA_SYSTEM | FA_LABEL |
           //FA_DIREC | FA_ARCH; // everything

    last = strlen(path)-1;
    while (last > 0 &&
           (path[last] == '\\' || path[last] == ' ' || path[last] == '\t')) {
        last--;
    }
    path[last+1] = 0; // delete any trailing backslash - Borland won't accept it
#ifdef EBORLAND
    dirp = findfirst(path, &direntp, bits);
#else
    dirp = _findfirst(path, &direntp);
#endif
    if (path[last] == ':' ||
        (dirp != -1 && (
#ifdef EBORLAND
        direntp.ff_attrib
#else
        direntp.attrib
#endif
        /* BUG FIX by EUMAN 2002
           Borland and LCC-Win would not show sub-directories/files
           of a given directory if attributes element was an or'd value,
           e.g. READ_ONLY | SUBDIR. */

        &   /* THE FIX: use bitwise AND, not == _A_SUBDIR */

        _A_SUBDIR) &&

        strchr(path, '*') == NULL &&
        strchr(path, '?') == NULL)) {
        // it's a single directory entry - add *.*
        strcat(path, "\\*.*");
#ifdef EBORLAND
        dirp = findfirst(path, &direntp, bits);
#else
        dirp = _findfirst(path, &direntp);
#endif
    }
    if (dirp == -1)
        return ATOM_M1; /* couldn't open directory (or file) */

    /* start with empty sequence as result */
    result = (s1_ptr)NewString("");

    for (;;) {
        /* create a length-9 sequence */
        row = NewS1((long)9);

        obj_ptr = row->base;
        obj_ptr[1] = NewString(
#ifdef EBORLAND
        direntp.ff_name
#else
        direntp.name
#endif
        );
        obj_ptr[2] = NewString("");
        temp = &obj_ptr[2];
#ifdef EBORLAND
        attrib = direntp.ff_attrib;
#else
        attrib = direntp.attrib;
#endif
        if (attrib & _A_RDONLY)
            Append(temp, *temp, MAKE_INT('r'));
        if (attrib & _A_HIDDEN)
            Append(temp, *temp, MAKE_INT('h'));
        if (attrib & _A_SYSTEM)
            Append(temp, *temp, MAKE_INT('s'));
        if (attrib & _A_SUBDIR)
            Append(temp, *temp, MAKE_INT('d'));
        if (attrib & _A_ARCH)
            Append(temp, *temp, MAKE_INT('a'));
#ifdef EBORLAND
        if (attrib & FA_LABEL)
            Append(temp, *temp, MAKE_INT('v'));
        obj_ptr[3] = direntp.ff_fsize;
        date = direntp.ff_fdate;
        time = direntp.ff_ftime;
        obj_ptr[4] = 1980 + date/512;
        obj_ptr[5] = (date/32) & 0x0F;
        obj_ptr[6] = date & 0x01F;

        obj_ptr[7] = time/2048;
        obj_ptr[8] = (time/32) & 0x03F;
        obj_ptr[9] = (time & 0x01F) << 1;
#else
        obj_ptr[3] = direntp.size;
        {
        struct tm *now;

        now = localtime(&direntp.time_write);

        obj_ptr[4] = now->tm_year+1900;
        obj_ptr[5] = now->tm_mon+1;
        obj_ptr[6] = now->tm_mday;

        obj_ptr[7] = now->tm_hour;
        obj_ptr[8] = now->tm_min;
        obj_ptr[9] = now->tm_sec;
        }
#endif
        if ((unsigned)obj_ptr[3] > (unsigned)MAXINT) {
            // file size over 1Gb
            obj_ptr[3] = NewDouble((double)(unsigned)obj_ptr[3]);
        }
        /* append row to overall result (ref count 1) */
        Append((object_ptr)&result, (object)result, MAKE_SEQ(row));
#ifdef EBORLAND
        dirp = findnext(&direntp);
        if (dirp == -1)
            break; /* end of list */
#else
        if (_findnext(dirp, &direntp)) {
            _findclose(dirp);
            break; /* end of list */
        }
#endif
    }

    return (object)result;
}
#endif

#ifdef EWATCOM
    // 2 of 3: WATCOM method

static object Dir(object x)
/* x is the name of a directory or file */
{
    char path[MAX_FILE_NAME+1];
    s1_ptr result, row;
    struct dirent *direntp;
    object_ptr obj_ptr, temp;
    int last;
    DIR *dirp;

    /* x will be sequence if called via dir() */

    if (SEQ_PTR(x)->length > MAX_FILE_NAME)
        RTFatal("name for dir() is too long");

    MakeCString(path, x);

    last = strlen(path)-1;
    while (last > 0 &&
           (path[last] == '\\' || path[last] == ' ' || path[last] == '\t')) {
        last--;
    }

    if (last >= 1 && path[last-1] == '*' && path[last] == '.')
        last--; // work around WATCOM bug when we have "*." at end

    if (path[last] != ':')
        path[last+1] = 0; // delete any trailing backslash - Watcom has problems
                          // with wildcards and trailing backslashes together

    dirp = opendir(path);

    if (dirp == NULL) {
        return ATOM_M1; /* couldn't open directory (or file) */
    }

    /* start with empty sequence as result */
    result = (s1_ptr)NewString("");

    for (;;) {
        direntp = readdir(dirp);
        if (direntp == NULL)
            break; /* end of list */

        /* create a length-9 sequence */
        row = NewS1((long)9);
        obj_ptr = row->base;
        obj_ptr[1] = NewString(direntp->d_name);
        obj_ptr[2] = NewString("");
        temp = &obj_ptr[2];

        if (direntp->d_attr & _A_RDONLY)
            Append(temp, *temp, MAKE_INT('r'));
        if (direntp->d_attr & _A_HIDDEN)
            Append(temp, *temp, MAKE_INT('h'));
        if (direntp->d_attr & _A_SYSTEM)
            Append(temp, *temp, MAKE_INT('s'));
        if (direntp->d_attr & _A_VOLID)
            Append(temp, *temp, MAKE_INT('v'));
        if (direntp->d_attr & _A_SUBDIR)
            Append(temp, *temp, MAKE_INT('d'));
        if (direntp->d_attr & _A_ARCH)
            Append(temp, *temp, MAKE_INT('a'));

        obj_ptr[3] = MAKE_INT(direntp->d_size);
        if ((unsigned)obj_ptr[3] > (unsigned)MAXINT) {
            // file size over 1Gb
            obj_ptr[3] = NewDouble((double)(unsigned)obj_ptr[3]);
        }

        obj_ptr[4] = 1980 + direntp->d_date/512;
        obj_ptr[5] = (direntp->d_date/32) & 0x0F;
        obj_ptr[6] = direntp->d_date & 0x01F;

        obj_ptr[7] = direntp->d_time/2048;
        obj_ptr[8] = (direntp->d_time/32) & 0x03F;
        obj_ptr[9] = (direntp->d_time & 0x01F) << 1;

        /* append row to overall result (ref count 1)*/
        Append((object_ptr)&result, (object)result, MAKE_SEQ(row));
    }
    closedir(dirp);

    return (object)result;
}
#endif

#ifdef ELINUX
    // 3 of 3: Unix style with stat()
static object Dir(object x)
/* x is the name of a directory or file */
{
    char path[MAX_FILE_NAME+1];
    s1_ptr result, row;
    struct dirent *direntp;
    object_ptr obj_ptr, temp;

    DIR *dirp;
    int r;
    struct stat stbuf;
    struct tm *date_time;

    char full_name[MAX_FILE_NAME+1+NAME_MAX+1];

    /* x will be sequence if called via dir() */

    if (SEQ_PTR(x)->length > MAX_FILE_NAME)
        RTFatal("name for dir() is too long");

    MakeCString(path, x);

    dirp = opendir(path); // on Linux, path *must* be a directory

    if (dirp == NULL) {
        r = stat(path, &stbuf);  // should be a file
        if (r == -1)
            return ATOM_M1;
    }

    /* start with empty sequence as result */
    result = (s1_ptr)NewString("");

    for (;;) {
        if (dirp != NULL) {
            direntp = readdir(dirp);
            if (direntp == NULL)
                break; /* end of list */
        }

        /* create a length-9 sequence */
        row = NewS1((long)9);
        obj_ptr = row->base;
        if (dirp == NULL)
            obj_ptr[1] = NewString(name_ext(path)); // just the name
        else
            obj_ptr[1] = NewString(direntp->d_name);
        obj_ptr[2] = NewString("");
        temp = &obj_ptr[2];

        // opendir/readdir with stat method
        if (dirp != NULL) {
            strcpy(full_name, path);  // trailing blanks?
            strcat(full_name, "/");
            strcat(full_name, direntp->d_name);
            r = stat(full_name, &stbuf);
        }
        if (r == -1) {
            obj_ptr[3] = 0;
            obj_ptr[4] = 0;
            obj_ptr[5] = 0;
            obj_ptr[6] = 0;
            obj_ptr[7] = 0;
            obj_ptr[8] = 0;
            obj_ptr[9] = 0;
        }
        else {
            if ((stbuf.st_mode & S_IFMT) == S_IFDIR)
                Append(temp, *temp, MAKE_INT('d'));

            obj_ptr[3] = stbuf.st_size;
            if ((unsigned)obj_ptr[3] > (unsigned)MAXINT_VAL) {
                // file size over 1Gb
                obj_ptr[3] = NewDouble((double)(unsigned)obj_ptr[3]);
            }

            date_time = localtime(&stbuf.st_mtime);
            obj_ptr[4] = date_time->tm_year+1900;
            obj_ptr[5] = date_time->tm_mon+1;
            obj_ptr[6] = date_time->tm_mday;
            obj_ptr[7] = date_time->tm_hour;
            obj_ptr[8] = date_time->tm_min;
            obj_ptr[9] = date_time->tm_sec;
        }

        /* append row to overall result (ref count 1)*/
        Append((object_ptr)&result, (object)result, MAKE_SEQ(row));
        if (dirp == NULL)
            return (object)result;
    }
    closedir(dirp);

    return (object)result;
}
#endif

static object CurrentDir()
/* return name of current directory */
{
    char *cwd;
    object result;
    char *buff;

    buff = malloc(MAX_FILE_NAME+1);
    cwd = getcwd(buff, MAX_FILE_NAME+1);
    if (cwd == NULL)
        RTFatal("current directory not available");
    else {
        result = NewString(cwd);
        free(buff);
    }
    return result;
}

static object PutScreenChar(object x)
/* x is {line, col, {c1, a1, c2, a2, ...}} */
{
    unsigned c, attr, len;
    unsigned cur_line, cur_column, line, column;
    s1_ptr args;
    object_ptr p;
#ifdef ELINUX
    char s1[2];
    int save_line, save_col;
#elif EWINDOWS
    COORD coords;
    int temp;
    char cc[4];
#endif

#ifdef EWINDOWS
    show_console();
#endif
    args = SEQ_PTR(x);
    line =   get_int(*(args->base+1));
    column = get_int(*(args->base+2));
    x = *(args->base+3);
    args = SEQ_PTR(x);
    len = args->length;
    if (!IS_SEQUENCE(x) || (len & 1) != 0)
        RTFatal("third argument to put_screen_char() must be a sequence of even length");
    p = args->base+1;

#ifdef ELINUX
    save_line = screen_line;
    save_col = screen_col;
    SetPosition(line, column);
    while (len > 0) {
        c = get_pos_int("put_screen_char()", *p);
        attr = get_pos_int("put_screen_char()", *(p+1));
        SetTColor(attr & 15);
        SetBColor(attr >> 4);
        fputc(c, stdout);
        s1[0] = c;
        s1[1] = 0;
        update_screen_string(s1);
        screen_col++;
        p += 2;
        len -= 2;
    }
    SetPosition(save_line, save_col); // restore cursor location
    fflush(stdout);
#endif

#ifdef EWINDOWS
    while (len > 0) {
        cc[0] = get_pos_int("put_screen_char()", *p);
        attr  = get_pos_int("put_screen_char()", *(p+1));
        coords.X = column-1;
        coords.Y = line-1;
        column++;
        WriteConsoleOutputCharacter(console_output, (LPTSTR)&cc, 1, coords, (LPDWORD)&temp);
        WriteConsoleOutputAttribute(console_output, (LPWORD)&attr, 1, coords, (LPDWORD)&temp);
        p += 2;
        len -= 2;
    }
#endif

    return ATOM_1;
}

static object GetScreenChar(object x)
/* return {character, attributes} at given (line, col) location */
{
    struct rccoord pos;
    object_ptr obj_ptr;
    s1_ptr result, x1;
    unsigned c, cur_line, cur_column, line, column;
    struct rccoord p;
#ifdef EWINDOWS
    CONSOLE_SCREEN_BUFFER_INFO console_info;
    int temp, att;
    char ch[4];
    COORD coords;
#endif

    x1 = SEQ_PTR(x);
    line =   get_int(*(x1->base+1));
    column = get_int(*(x1->base+2));
    result = NewS1((long)2);
    obj_ptr = result->base;

#ifdef EWINDOWS
    show_console();

    coords.X = column-1;
    coords.Y = line-1;

    att = 0;
    ReadConsoleOutputCharacter(console_output, (LPTSTR)&ch, 1, coords, (LPDWORD)&temp);
    ReadConsoleOutputAttribute(console_output, (LPWORD)&att, 1, coords, (LPDWORD)&temp);

    obj_ptr[1] = ch[0];
    if ((unsigned)att <= (unsigned)MAXINT)
        obj_ptr[2] = att;
    else
        obj_ptr[2] = NewDouble((double)(unsigned)att);

#endif

#ifdef ELINUX
    if (line >= 1 && line <= line_max &&
        column >= 1 && column <= col_max) {
        obj_ptr[1] = screen_image[line-1][column-1].ascii;
        obj_ptr[2] = (screen_image[line-1][column-1].fg_color & 15) |
                     (screen_image[line-1][column-1].bg_color << 4);
    }
    else {
        obj_ptr[1] = ' ';
        obj_ptr[2] = 0;
    }
#endif

    return MAKE_SEQ(result);
}

static object GetPosition()
/* return {line, column} for cursor */
{
    struct rccoord pos;
    object_ptr obj_ptr;
    s1_ptr result;

    result = NewS1((long)2);
    obj_ptr = result->base;

#ifdef EWINDOWS
    CONSOLE_SCREEN_BUFFER_INFO console_info;

    show_console();
    GetConsoleScreenBufferInfo(console_output, &console_info);
    obj_ptr[1] = MAKE_INT(console_info.dwCursorPosition.Y+1);
    obj_ptr[2] = MAKE_INT(console_info.dwCursorPosition.X+1);
#else
    pos = _gettextposition();
    obj_ptr[1] = MAKE_INT(pos.row);
    obj_ptr[2] = MAKE_INT(pos.col);
#endif
    return MAKE_SEQ(result);
}

static object flush_file(object x)
/* flush an open user file */
{
    if (x != last_w_file_no) {
        last_w_file_ptr = which_file(x, EF_WRITE);
        if (IS_ATOM_INT(x))
            last_w_file_no = x;
        else
            last_w_file_no = NOVALUE;
    }
    fflush(last_w_file_ptr);
    return ATOM_1;
}

static object lock_file(object x)
/* lock a file. x is {fn, t, {first-byte, last-byte}} */
{
    FILE *f;
    int fd;
    int r, t;
    unsigned long first, last;
    object fn, s;

    // get 1st element of x - file number - assume x is a sequence of length 3
    x = (object)SEQ_PTR(x);
    fn = *(((s1_ptr)x)->base+1);
    f = which_file(fn, EF_READ | EF_WRITE);
    fd = fileno(f);

#ifdef ELINUX
    // get 2nd element of x - lock type
    t = get_int(*(((s1_ptr)x)->base+2));
    if (t == 1)
        r = flock(fd, LOCK_SH | LOCK_NB);
    else
        r = flock(fd, LOCK_EX | LOCK_NB);
#else
    // get 3rd element of x - range - assume it's a sequence
    s = *(((s1_ptr)x)->base+3);
    s = (object)SEQ_PTR(s);
    if (((s1_ptr)s)->length == 0) {
        first = 0;
        last = 0xFFFFFFFE;
    }
    else if (((s1_ptr)s)->length == 2) {
        first = get_int(*(((s1_ptr)s)->base+1));
        last =  get_int(*(((s1_ptr)s)->base+2));
    }
    else {
        RTFatal("3rd argument to lock_file must be a sequence of length 0 or 2");
    }
    if (last < first)
        return ATOM_0;
#ifdef ELCC
    r = 0;  // FOR NOW!
#else
    r = lock(fd, first, last - first + 1);
#endif
#endif
    if (r == 0)
        return ATOM_1; // success
    else
        return ATOM_0; // fail
}

static object unlock_file(object x)
/* unlock a file */
{
    int fd;
    FILE *f;
    unsigned long first, last;
    object fn, s;

    // get 1st element of x - can assume x is a sequence of length 2
    x = (object)SEQ_PTR(x);
    fn = *(((s1_ptr)x)->base+1);
    f = which_file(fn, EF_READ | EF_WRITE);
    fd = fileno(f);
#ifdef ELINUX
    flock(fd, LOCK_UN);
#else
    // get 2nd element of x - range - assume it's a sequence
    s = *(((s1_ptr)x)->base+2);
    s = (object)SEQ_PTR(s);
    if (((s1_ptr)s)->length == 0) {
        first = 0;
        last = 0xFFFFFFFE;
    }
    else if (((s1_ptr)s)->length == 2) {
        first = get_int(*(((s1_ptr)s)->base+1));
        last =  get_int(*(((s1_ptr)s)->base+2));
    }
    else {
        RTFatal("2nd argument to unlock_file must be a sequence of length 0 or 2");
    }
#ifdef ELCC
    /* do nothing */
#else
    if (last >= first)
        unlock(fd, first, last - first + 1);
#endif
#endif
    return ATOM_1; // ignored
}

static object set_rand(object x)
/* set random number generator */
{
    int r;

    r = get_int(x);

    seed1 = INT_VAL(r)+1;
    seed2 = ~(INT_VAL(r)) + 999;

    rand_was_set = TRUE;

    if (seed1 == 0)
        seed1 = 1;
    if (seed2 == 0)
        seed2 = 1;

    return ATOM_1;
}

static object crash_message(object x)
/* record user's message in case of a crash */
{
    if (crash_msg != NULL)
        EFree(crash_msg);

    if (!IS_SEQUENCE(x) || SEQ_PTR(x)->length == 0) {
        crash_msg = NULL;
    }
    else {
        crash_msg = EMalloc(SEQ_PTR(x)->length + 1);
        MakeCString(crash_msg, x);
    }
    return ATOM_1;
}

static object crash_file(object x)
/* record user's alternate path for ex.err */
/* assume x is a sequence */
{
    // use malloc/free
    free(TempErrName);
    TempErrName = malloc(SEQ_PTR(x)->length + 1);
    MakeCString(TempErrName, x);
    return ATOM_1;
}

static object change_dir(object x)
/* change to a new current directory */
/* assume x is a sequence */
{
    char *new_dir;
    int r;

    new_dir = malloc(SEQ_PTR(x)->length + 1);
    MakeCString(new_dir, x);
    r = chdir(new_dir);
    free(new_dir);
    if (r == 0)
        return ATOM_1;
    else
        return ATOM_0;
}

static object e_sleep(object x)
/* sleep for x seconds */
{
    int t;

    t = get_int(x);
#ifdef ELCC
    Sleep(1000 * t);
#else
    sleep(t);
#endif
    return ATOM_1;
}

double current_time()
/* return value for time() function */
{
#ifdef ELINUX
    struct tms buf;
#endif
    if (clock_frequency == 0.0) {
        /* no handler */
        return (double)
#ifdef ELINUX
        times(&buf) / clk_tck
#else
        clock() / (double)clocks_per_sec
#endif
         + clock_adjust;
    }
    else {
        /* our handler is installed */
        return base_time / clock_frequency;
    }
}

object tick_rate(object x)
/* Set new system clock tick (interrupt) rate.
   x may be int or double, >= 0. 0 means restore 18.2 rate. */
{
    double rate;

/*** WARNING : BECAUSE THIS IS ALL IN #ifdef EDOS, NOBODY REALLY CALLS THIS!!! ***/
#ifdef EDOS
    if (IS_ATOM_INT(x))
        rate = (double)INT_VAL(x);
    else if (IS_ATOM(x)) {
        rate = DBL_PTR(x)->dbl;
    }
    else
        rate = -1.0;
    if (rate == 0.0) {
        /* remove our handler, use normal DOS clock() at 18.2/sec */
        /* no more profiling */
        if (clock_frequency != 0.0) {
            CleanUpTimer();
            clock_adjust = (double)
#ifdef ELINUX
            times(&buf) / CLK_TCK;  //N.B. DOS-only section right now
#else
            clock()/clocks_per_sec;
#endif
            clock_adjust = current_time() - clock_adjust;
            clock_frequency = 0.0;
        }
        clock_period = 1.0/18.2;
        return ATOM_1;
    }

    if (rate < 18.3 || rate > MASTER_FREQUENCY)
        RTFatal("bad argument to tick_rate()");

    clock_period = 1.0/rate;

    if (clock_frequency != 0.0)
        CleanUpTimer();
    base_time = current_time();
    clock_ticks = 0;
    interval = (int) (MASTER_FREQUENCY / rate + 0.5);
    clock_frequency = MASTER_FREQUENCY / (double)interval;

    ESetTimer(TickHandler);

#endif
    return ATOM_1;
}

static object float_to_atom(object x, int flen)
/* convert a sequence of 4 or 8 bytes in IEEE format to an atom */
{
    int len, i;
    object_ptr obj_ptr;
    char fbuff[8];
    double d;

    x = (object)SEQ_PTR(x);
    len = ((s1_ptr)x)->length;
    if (len != flen)
        RTFatal("sequence has wrong length");
    obj_ptr = ((s1_ptr)x)->base+1;
    for (i = 0; i < len; i++) {
        fbuff[i] = (char)obj_ptr[i];
    }
    if (flen == 4)
        d = (double)*((float *)&fbuff);
    else
        d = *((double *)&fbuff);
    return NewDouble(d);
}

static object fpsequence(unsigned char *fp, int len)
/* return a sequence of bytes for a floating-point number */
{
    s1_ptr result;
    object_ptr obj_ptr;
    int i;

    if (len == 0)
        RTFatal("in machine_func an atom was expected, not a sequence");
    result = NewS1(len);
    obj_ptr = result->base+1;

    for (i = 0; i < len; i++) {
        obj_ptr[i] = fp[i];
    }
    return MAKE_SEQ(result);
}

static object atom_to_float64(object x)
/* convert an atom to a sequence of 8 bytes IEEE format */
{
    double d;
    int len;

    len = 8;
    if (IS_ATOM_INT(x)) {
        d = (double)INT_VAL(x);
    }
    else if (IS_ATOM(x)) {
        d = DBL_PTR(x)->dbl;
    }
    else
        len = 0;
    return fpsequence((char *)&d, len);
}

static object atom_to_float32(object x)
/* convert an atom to a sequence of 4 bytes in IEEE format */
{
    float f;
    int len;

    len = 4;
    if (IS_ATOM_INT(x)) {
        f = (float)INT_VAL(x);
    }
    else if (IS_ATOM(x)) {
        f = (float)(DBL_PTR(x)->dbl);
    }
    else
        len = 0;
    return fpsequence((char *)&f, len);
}

object memory_copy(object d, object s, object n)
/* Fast memory to memory copy - called from x.c or machine.c */
{
    char *dest;
    char *src;
    unsigned nbytes;

    dest   = (char *)get_pos_int("mem_copy", d);
    src    = (char *)get_pos_int("mem_copy", s);
    nbytes = get_pos_int("mem_copy", n);

    memmove(dest, src, nbytes); /* overlapping regions handled correctly */
    return ATOM_1;
}

object memory_set(object d, object v, object n)
/* Fast memory set - called from x.c or machine.c */
{
    char *dest;
    int value;
    unsigned nbytes;

    dest   = (char *)get_pos_int("mem_set", d);
    value  = (int)get_pos_int("mem_set", v);
    nbytes = get_pos_int("mem_set", n);

    memset(dest, value, nbytes);
    return ATOM_1;
}

object OpenDll(object x)
{
    void (FAR WINAPI *proc_address)();
    s1_ptr dll_ptr;
    unsigned char *dll_string;
    HINSTANCE lib;

    /* x will be a sequence if called via open_dll() */

    dll_ptr = SEQ_PTR(x);
    if (dll_ptr->length >= TEMP_SIZE)
        RTFatal("name for open_dll() is too long");
    dll_string = TempBuff;
    MakeCString(dll_string, (object)x);
#ifdef EWINDOWS
    lib = (HINSTANCE)LoadLibrary(dll_string);
    // add to dll list so we can close it at end of execution
    if (open_dll_list == NULL) {
        open_dll_list = (HINSTANCE *)malloc(open_dll_size * sizeof(HINSTANCE));
    }
    else if (open_dll_count >= open_dll_size) {
        open_dll_size *= 2;
        open_dll_list = (HINSTANCE *)realloc(open_dll_list,
                                             open_dll_size * sizeof(HINSTANCE));
    }
    open_dll_list[open_dll_count++] = lib;
#else
    // Linux

    lib = (HINSTANCE)dlopen(dll_string, RTLD_LAZY | RTLD_GLOBAL);

#endif
    if ((unsigned)lib <= (unsigned)MAXINT_VAL)
        return MAKE_INT((unsigned long)lib);
    else
        return NewDouble((double)(unsigned long)lib);
}

object DefineCVar(object x)
/* Get the address of a C variable, or return -1 */
{
    HINSTANCE lib;
    object variable_name;
    s1_ptr variable_ptr;
    unsigned char *variable_string;
    char *variable_address;
    object arg_size, return_size;
    unsigned addr;

    // x will be a sequence if called from define_c_func/define_c_proc
    x = (object)SEQ_PTR(x);

    lib = (HINSTANCE)*(((s1_ptr)x)->base+1);
    lib = (HINSTANCE)get_pos_int("define_c_proc/func", (object)lib);

    variable_name =  *(((s1_ptr)x)->base+2);
    if (IS_ATOM(variable_name))
        RTFatal("variable name must be a sequence");

    variable_ptr = SEQ_PTR(variable_name);
    if (variable_ptr->length >= TEMP_SIZE)
        RTFatal("variable name is too long");
    variable_string = TempBuff;
    MakeCString(variable_string, variable_name);
#ifdef EWINDOWS
    //Ray Smith says this works.
    variable_address = (char *)(int (*)())GetProcAddress((void *)lib, variable_string);
    if (variable_address == NULL)
        return ATOM_M1;
#else
    // Linux
    variable_address = (char *)dlsym((void *)lib, variable_string);
    if (dlerror() != NULL)
        return ATOM_M1;
#endif
    addr = (unsigned)variable_address;
    if (addr <= (unsigned)MAXINT_VAL)
        return MAKE_INT(addr);
    else
        return NewDouble((double)addr);
}


object DefineC(object x)
/* define a C routine: x is {lib, name, arg_sizes, return_type or 0}
   alternatively, x is {"", address or {'+', address}, arg_sizes, return_type or 0}
   Return -1 on failure. */
{
    HINSTANCE lib;
    object routine_name;
    s1_ptr routine_ptr;
    unsigned char *routine_string;
    int (*proc_address)();
    object arg_size, return_size;
    object_ptr arg;
    int convention, t, raw_addr;

    // x will be a sequence if called from define_c_func/define_c_proc
    x = (object)SEQ_PTR(x);

    lib = (HINSTANCE)*(((s1_ptr)x)->base+1);
    raw_addr = FALSE;

    if (IS_SEQUENCE(lib)) {
        /* machine code: must be length-0, implies 2nd arg is
           address or {'+', address} */
        if (SEQ_PTR(lib)->length != 0)
            RTFatal("first argument of define_c_proc/func must be an atom or an empty sequence");
        raw_addr = TRUE;
    }
    else {
        /* 32-bit address of lib was supplied */
        lib = (HINSTANCE)get_pos_int("define_c_proc/func", (object)lib);
    }

    routine_name = *(((s1_ptr)x)->base+2);
    convention = C_STDCALL;

    if (raw_addr) {
        /* machine code routine */
        if (IS_ATOM(routine_name)) {
            /* addr */
            proc_address = (int (*)())get_pos_int("define_c_proc/func",
                                        (object)routine_name);
        }
        else {
            /* {'+', addr} */
            if (SEQ_PTR(routine_name)->length != 2)
                RTFatal("expected {'+', address} as second argument of define_c_proc/func");
            proc_address = (int (*)())*(SEQ_PTR(routine_name)->base+2);
            proc_address = (int (*)())get_pos_int("define_c_proc/func", (object)proc_address);
#ifdef EWINDOWS
            t = (int)*(SEQ_PTR(routine_name)->base+1);
            t = get_pos_int("define_c_proc/func", (object)t);
            if (t == '+')
                convention = C_CDECL;
            else
                RTFatal("unsupported calling convention - use '+' for CDECL");
#endif
        }
        /* assign a sequence value to routine_ptr */
        sprintf(TempBuff, "machine code routine at %x", proc_address);
        routine_name = NewString(TempBuff);
        routine_ptr = SEQ_PTR(routine_name);
    }

    else {
        /* C .dll routine */
        if (IS_ATOM(routine_name))
            RTFatal("routine name must be a sequence");
        routine_ptr = SEQ_PTR(routine_name);
        Ref(routine_name);
        if (routine_ptr->length >= TEMP_SIZE)
            RTFatal("routine name is too long");
        routine_string = TempBuff;
        MakeCString(routine_string, routine_name);
#ifdef EWINDOWS
        if (routine_string[0] == '+') {
            routine_string++;
            convention = C_CDECL;
        }
        proc_address = (int (*)())GetProcAddress((void *)lib, routine_string);
        if (proc_address == NULL)
            return ATOM_M1;
#else
#ifdef ELINUX
        proc_address = (int (*)())dlsym((void *)lib, routine_string);
        if (dlerror() != NULL)
            return ATOM_M1;
#endif
#endif
    }

    if (c_routine_next >= c_routine_size) {
        if (c_routine == NULL) {
            c_routine_size = 20;
            c_routine = (struct arg_info *)EMalloc(c_routine_size * sizeof(struct arg_info));
        }
        else {
            c_routine_size *= 2;
            c_routine = (struct arg_info *)ERealloc((char *)c_routine,
                                 c_routine_size * sizeof(struct arg_info));
        }
    }

    arg_size = *(((s1_ptr)x)->base+3);
    if (IS_ATOM(arg_size))
        RTFatal("argument size list must be a sequence");
    RefDS(arg_size);

    arg = SEQ_PTR(arg_size)->base+1;
    while (*arg != NOVALUE) {
        if (IS_ATOM_INT(*arg)) {
            t = *arg;
        }
        else if (IS_ATOM(*arg)) {
            t = (unsigned long)DBL_PTR(*arg)->dbl;
        }
        else
            RTFatal("argument type may not be a sequence");

        if (t < C_CHAR || t > C_DOUBLE)
            RTFatal("Invalid argument type");

        arg++;
    }

    return_size = *(((s1_ptr)x)->base+4);

    if (IS_ATOM_INT(return_size)) {
        t = return_size;
    }
    else if (IS_ATOM(return_size)) {
        t = (unsigned long)DBL_PTR(return_size)->dbl;
    }
    else
        RTFatal("return type must be an atom");

    if (t != 0 && (t < C_CHAR || t > C_DOUBLE))
        RTFatal("Invalid return type");

    c_routine[c_routine_next].address = proc_address;
    c_routine[c_routine_next].name = routine_ptr;
    c_routine[c_routine_next].arg_size = SEQ_PTR(arg_size);
    c_routine[c_routine_next].return_size = t;
    c_routine[c_routine_next].convention = convention;

    return c_routine_next++;
}

object CallBack(object x)
/* return a call-back address for routine id x
   x can be the routine id for stdcall, or {'+', routine_id} for cdecl */
{
    unsigned addr;
    int routine_id, i, num_args;
    unsigned char *copy_addr;
    symtab_ptr routine;
    s1_ptr x_ptr;
    int convention;

    if (IS_SEQUENCE(x)) {
        x_ptr = SEQ_PTR(x);
        if (x_ptr->length != 2)
            RTFatal("call_back() argument must be routine_id, or {'+', routine_id}");
        if (get_int(*(x_ptr->base+1)) != '+')
            RTFatal("for cdecl, use call_back({'+', routine_id})");
        routine_id = get_int(*(x_ptr->base+2));
        convention = C_CDECL;
    }
    else {
        routine_id = get_int(x);
        convention = C_STDCALL;
    }

    if ((unsigned)routine_id >= e_routine_next)
        RTFatal("call_back: bad routine id\n");
    routine = e_routine[routine_id];

    if (routine->token == PROC)
        RTFatal("call-back routine must be a function or type");
    num_args = routine->num_args;

    if (convention == C_CDECL) {
        // cdecl allows var args - only one template needed
        addr = (unsigned)&cdecl_call_back;
    }
    else {
        switch (num_args) {
            case 0: addr = (unsigned)&call_back0;
                    break;
            case 1: addr = (unsigned)&call_back1;
                    break;
            case 2: addr = (unsigned)&call_back2;
                    break;
            case 3: addr = (unsigned)&call_back3;
                    break;
            case 4: addr = (unsigned)&call_back4;
                    break;
            case 5: addr = (unsigned)&call_back5;
                    break;
            case 6: addr = (unsigned)&call_back6;
                    break;
            case 7: addr = (unsigned)&call_back7;
                    break;
            case 8: addr = (unsigned)&call_back8;
                    break;
            case 9: addr = (unsigned)&call_back9;
                    break;
            default:
                    RTFatal("routine has too many parameters for call-back");
        }
    }

    copy_addr = (unsigned char *)EMalloc(CALLBACK_SIZE);
#ifdef ELINUX
#ifndef EBSD
    mprotect((unsigned)copy_addr & ~(pagesize-1),  // start of page
             pagesize,  // one page
             PROT_READ+PROT_WRITE+PROT_EXEC);
#endif
#endif
    memcpy(copy_addr, (char *)addr, CALLBACK_SIZE);
    // Plug in the symtab pointer
    // Find 78 56 34 12
    for (i = 4; i < CALLBACK_SIZE-4; i++) {
        if (copy_addr[i]   == 0x078 &&
            copy_addr[i+1] == 0x056) {
            *(symtab_ptr *)(copy_addr+i) = e_routine[routine_id];
            break;
        }
    }
    addr = (unsigned)copy_addr;

    if (addr <= (unsigned)MAXINT_VAL)
        return addr;
    else
        return NewDouble((double)addr);
}

static object crash_routine(object x)
/* add a new routine id to the list to be called if there's a crash */
{
    int r;

    r = get_int(x);
    if (r < 0 || r >= e_routine_next)
        RTFatal("invalid routine id passed to crash_routine()");

    if (crash_list == NULL) {
        crash_size = 5;
        crash_list = (int *)EMalloc(sizeof(int) * crash_size);
    }
    else if (crash_routines >= crash_size) {
        crash_size += 10;
        crash_list = (int *)ERealloc(crash_list, sizeof(int) * crash_size);
    }
    crash_list[crash_routines++] = r;

    return ATOM_1;
}

void Machine_Handler(int sig_no)
/* illegal instruction, segmentation violation */
{
    RTFatal("A machine-level exception occurred during execution of this statement");
}

void my_start_backend(il my_il)
{
    fe.st = my_il.st;
    fe.sl = NULL;
    fe.misc = NULL;
    fe.lit = NULL;

    InitInOut();
    InitGraphics();
    InitEMalloc();
    setran();
    InitFiles();
    TempErrName = (char *)malloc(8);  // malloc, not EMalloc
    strcpy(TempErrName, "ex.err");

#ifdef EBORLAND
    PatchCallc();
#endif

    fe_set_pointers();
    be_init();
    InitExecute();
    InitTraceWindow();
    Execute(TopLevelSub->code);
}

object machine(object opcode, object x)
/* Machine-specific function "machine". It is passed an opcode and
   a general Euphoria object as its parameters and it returns a
   Euphoria object as a result. */
{
    double d;
    int bval, temp;
    char *dest, *src;
    unsigned addr;
    unsigned long nbytes;

    while (TRUE) {
        switch(opcode) {  /* tricky - could be atom or sequence */
            /* Remove */
            case M_COMPLETE:
            case M_SOUND:
            case M_LINE:
            case M_POLYGON:
            case M_PIXEL:
            case M_GET_PIXEL:
            case M_ELLIPSE:
            case M_PALETTE:
            case M_ALL_PALETTE:
                return ATOM_M1;
                break;

            case M_SET_T_COLOR:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return SetTColor(x);
                break;

            case M_SET_B_COLOR:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return SetBColor(x);
                break;

            case M_GRAPHICS_MODE:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return Graphics_Mode(x);
                break;

            case M_VIDEO_CONFIG:
                return Video_config(); /* 0 args */
                break;

            case M_CURSOR:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return Cursor(x);
                break;

            case M_TEXTROWS:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return TextRows(x);
                break;

            case M_WRAP:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return Wrap(x);
                break;

            case M_SCROLL:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return Scroll(x);
                break;

            case M_WAIT_KEY:
#ifdef EWINDOWS
                show_console();
#endif
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return ATOM_0 + get_key(TRUE);
                break;

            /* Remove */
            case M_GET_MOUSE:
            case M_MOUSE_EVENTS:
            case M_MOUSE_POINTER:
                return ATOM_M1;
                break;

            case M_ALLOC:
                return user_allocate(x);
                break;

            case M_FREE:
                addr = get_pos_int("free", x);
                free((char *)addr);
                return ATOM_1;
                break;

            case M_SEEK:
                return Seek(x);
                break;

            case M_WHERE:
                return Where(x);
                break;

            case M_DIR:
                return Dir(x);
                break;

            case M_CURRENT_DIR:
                return CurrentDir();
                break;

            case M_GET_POSITION:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return GetPosition();
                break;

            case M_GET_SCREEN_CHAR:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return GetScreenChar(x);
                break;

            case M_PUT_SCREEN_CHAR:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                return PutScreenChar(x);
                break;

            /* Remove */
            case M_GET_DISPLAY_PAGE:
            case M_SET_DISPLAY_PAGE:
            case M_GET_ACTIVE_PAGE:
            case M_SET_ACTIVE_PAGE:
            case M_ALLOC_LOW:
            case M_FREE_LOW:
            case M_INTERRUPT:
                return ATOM_M1;
                break;

            case M_SET_RAND:
                return set_rand(x);
                break;

            case M_USE_VESA:
                return ATOM_M1;
                break;

            case M_CRASH_MESSAGE:
                return crash_message(x);
                break;

            case M_TICK_RATE:
                return tick_rate(x);
                break;

            case M_ALLOW_BREAK:
                allow_break = get_int(x);
                return ATOM_1;
                break;

            case M_CHECK_BREAK:
                break;

            case M_MEM_COPY:
                /* obsolete, but keep it */
                x = (object)SEQ_PTR(x);
                return memory_copy(*(((s1_ptr)x)->base+1),
                                   *(((s1_ptr)x)->base+2),
                                   *(((s1_ptr)x)->base+3));
                break;
            case M_MEM_SET:
                /* obsolete, but keep it */
                x = (object)SEQ_PTR(x);
                return memory_set(*(((s1_ptr)x)->base+1),
                                  *(((s1_ptr)x)->base+2),
                                  *(((s1_ptr)x)->base+3));
                break;
            case M_A_TO_F64:
                return atom_to_float64(x);
                break;

            case M_A_TO_F32:
                return atom_to_float32(x);
                break;

            case M_F64_TO_A:
                return float_to_atom(x, 8);
                break;

            case M_F32_TO_A:
                return float_to_atom(x, 4);
                break;

            case M_OPEN_DLL:
                return OpenDll(x);
                break;

            case M_DEFINE_C:
                return DefineC(x);
                break;

            case M_CALLBACK:
                return CallBack(x);
                break;

            case M_PLATFORM:
                /* obsolete, but keep it */
#ifdef ELINUX
                return 3;  // Linux
#elif EWINDOWS
                return 2;  // WIN32
#endif
                break;

            case M_INSTANCE:
#ifdef EWINDOWS
                if ((unsigned)winInstance <= (unsigned)MAXINT)
                    return (unsigned)winInstance;
                else
                    return NewDouble((double)(unsigned)winInstance);
#else
                return 0;
#endif
                break;

            case M_FREE_CONSOLE:
                if (current_screen != MAIN_SCREEN)
                    MainScreen();
                if (have_console) {
#ifndef ELINUX
                    FreeConsole();
#endif
                    have_console = FALSE;
                }

                // no-op in DOS
                return ATOM_1;
                break;

            case M_DEFINE_VAR:
                return DefineCVar(x);
                break;

            case M_CRASH_FILE:
                return crash_file(x);
                break;

            case M_FLUSH:
                return flush_file(x);
                break;

            case M_LOCK_FILE:
                return lock_file(x);
                break;

            case M_UNLOCK_FILE:
                return unlock_file(x);
                break;

            case M_CHDIR:
                return change_dir(x);
                break;

            case M_SLEEP:
                return e_sleep(x);
                break;

            case M_CRASH_ROUTINE:
                return crash_routine(x);
                break;

            /* remember to check for MAIN_SCREEN wherever appropriate ! */
            default:
                /* could be out-of-range int, or double, or sequence */
                if (IS_ATOM_INT(opcode)) {
                    sprintf(TempBuff, "machine_proc/func(%d,...) not supported", opcode);
                    RTFatal(TempBuff);
                }
                else if (IS_ATOM(opcode)) {
                    d = DBL_PTR(opcode)->dbl;
                    if (d < 0.0 || d >= MAXDBL_VAL)
                        RTFatal("the first argument of machine_proc/func must be a small positive integer");
                    opcode = (long)d;
                }
                else {
                    RTFatal("the first argument of machine_proc/func must be an integer");
                }
                /* try again at top of while loop */
        }
    }
}

